;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: System; Base: 10 -*-
;;;;
;;;; evcl - 7 Objects - Discriminator with Compiler
;;; lisp/clos/o06-cdfun.lisp
;;;
;;; This file is part of Evita Common Lisp.
;;;
;;; Copyright (C) 1996-2006 by Project Vogue.
;;; Written by Yoshifumi "VOGUE" INOUE. (yosi@msn.com)
;;;
;;; @(#)$Id: //proj/evcl3/mainline/lisp/clos/o06-cdfun.lisp#4 $
;;;
;;; Description:
;;;  This file contains discriminator generating functions which use compiler.
;;;
;;;     make-dfun-ctor/checking
;;;     make-dfun-ctor/dispatch
;;;     make-discriminator/checking
;;;     make-discriminator/dispatch
;
(in-package :si)

;;;; make-dfun-ctor/checking
;;;
;;; Syntax:
;;;   make-dfun-ctor/checking param-info method dname => form
;;;
;;; Arguments and Values:
;;;   param-info  - A param-info.
;;;   method    - A method object which has at least one specializer.
;;;   dname     - A list represents name of constructor.
;;;   form      - A list represents constructor lambda expression.
;
(defun make-dfun-ctor/checking (param-info has-eql-p needs-next-methods-p
                                dname )
    (declare (type param-info param-info))
    (declare (type t has-eql-p))
    (declare (type t needs-next-methods-p))
    (declare (type t dname))
    (declare (values list))
  (multiple-value-bind (reqs opts var-rest lambda-list ropts)
      (make-temporary-lambda-list param-info)
    (labels (
      (call (fn &rest args)
          (declare (dynamic-extent args))
        (cond
          (opts
            `(cond
               (,(third (first ropts))
                 ,(if (not var-rest)
                      `(funcall ,fn ,@args ,@reqs ,.(mapcar #'first opts))
                    `(apply ,fn ,@args ,@reqs ,.(mapcar #'first opts)
                            ,var-rest )) )
               ,@(loop for rscan on (rest ropts)
                       for opt = (first rscan)
                   collect
                     `(,(third opt)
                        (funcall ,fn ,@args ,@reqs
                                 ,.(mapcar #'first (reverse rscan)) ) ))
               (t
                 (funcall ,fn ,@args ,@reqs) )) )
          (var-rest
            `(apply ,fn ,@args ,@reqs ,var-rest) )
          (t
            `(funcall ,fn ,@args ,@reqs) )) )
      )
      ;;
      `(lambda (gf vector)
           (declare (ext:lambda-name (:constructor ,dname)))
           ;; vector[0]   = method-function
           ;; vector[1]   = default-method or no-applicable-method
           ;; vector[2]   = specialize_0
           ;; ...
           ;; vector[n+1] = specialzier_n-1
         #'(lambda (,@lambda-list
                    ,@(and needs-next-methods-p
                        `(&aux *next-methods*) ))
               (declare (ext:lambda-name (:discriminator ,dname)))

             (let ((fnindex 1))
                (declare (optimize (speed 3) (safety 0) (space 0)))
               (block nil
                 (tagbody
                   ,@(loop
                       for param in reqs
                       for index = 2 then (1+ index)
                         collect
                           `(check-arg/checking
                              ,param
                              (svref vector ,index)
                              ,has-eql-p ) )
                   (setq fnindex 0)

                   ,@(when needs-next-methods-p
                       `((setq *next-methods* (list (svref vector 1)))) )

                 not-applicable
                   (return ,(call '(svref vector fnindex)))

                 obsolete-instance
                   (return ,(call #'initial-discriminator 'gf)) )) ) ) ) ) ) )


;;;; make-dfun-ctor/dispatch
;;;
;;; Description:
;;;   This function returns a constructor lambda form.
;;;
;;; Discriminator generated by the ctor.
;;;   1. Compute hash-code and check obsolete instance for each required
;;;      argument.
;;;   2. Scan hash-table entry by hash-code.
;;;   3. If found, transfer control to emf in entry.
;;;   4. If not found, compute emf and store it into hash-table.
;;;
;;; Note: We don't check obsolete instance for non-specialized arguments.
;;;
;;;     vector[0]   = method-cache
;;;     vector[1]   = default-method (constant)
;;;     vector[2]   = eql-methods (NYI)
;;;     vector[3]   = line-size (for debugging)
;
(defun make-dfun-ctor/dispatch (param-info has-eql-p dname speclvec nspecls
                                &aux (line-size (power-2 (1+ nspecls))) )
  (multiple-value-bind (reqs opts var-rest lambda-list ropts)
      (make-temporary-lambda-list param-info)
    (labels (
      ;; call
      (call (fn &rest args)
          (declare (dynamic-extent args))
        (cond
          (opts
            `(cond
               (,(third (first ropts))
                 ,(if (not var-rest)
                      `(funcall ,fn ,@args ,@reqs ,.(mapcar #'first opts))
                    `(apply ,fn ,@args ,@reqs ,.(mapcar #'first opts)
                            ,var-rest )) )
               ,@(loop for rscan on (rest ropts)
                       for opt = (first rscan)
                   collect
                     `(,(third opt)
                        (funcall ,fn ,@args ,@reqs
                                 ,.(mapcar #'first (reverse rscan)) ) ))
               (t
                 (funcall ,fn ,@args ,@reqs) )) )
          (var-rest
            `(apply ,fn ,@args ,@reqs ,var-rest) )
          (t
            `(funcall ,fn ,@args ,@reqs) )) )
      )
      ;;
      ;; Constructor lambda form.
      ;;
      `(lambda (gf cache default-emf)
           (declare (ext:lambda-name (:constructor ,dname)))
           (declare (type simple-vector cache))
         #'(lambda (,@lambda-list)
               (declare (ext:lambda-name (:discriminator ,dname)))
             (block dispatch
               (let* ((mask      (- (length cache) ,line-size))
                      (start     0)
                      (index     0)
                      (hash-code 0) )
                    (declare (optimize (speed 3) (safety 0) (space 0)))
                    (declare (type sequence-index start mask index))
                    (declare (type fixnum hash-code))
                 (tagbody
                   ;; Compute hash-code
                   ,@(loop
                        for req in reqs
                        for index = 0 then (1+ index)
                          when (svref speclvec index)
                            collect
                              `(let ((classd (classd-of ,req)))
                                 (when (zerop (ref classd hash-code classd))
                                   (update-obsolete-instance ,req)
                                   (go obsolete-instance) )
                                 (incf hash-code
                                       (ref classd hash-code classd) )))
                     (setq start (logand hash-code mask))
                     (setq index start)

                 loop
                   ;; Check entry
                   ,@(loop
                       for  req in reqs
                       for  index  = 0 then (1+ index)
                       with offset = 0
                       when (svref speclvec index)
                         collect
                           `(unless (eq (svref cache (+ ,offset index))
                                        (classd-of ,req) )
                              (go not-found) )
                         and do (incf offset) )

                   ;; Found entry
                   ,(if (not has-eql-p)
                       `(return-from dispatch
                          ,(call `(svref cache (+ ,nspecls index))) )
                      `(let ((emf (svref cache (+ ,nspecls index))))
                         (if (functionp emf)
                             (return-from dispatch (call 'emf))
                           (dolist (specls.efm emf)
                             (block eql
                               (let ((specls (car specls.efm)))
                                 ,@(loop
                                     for req in reqs
                                       collect
                                       `(let ((specl (pop specls)))
                                          (when (and (typep specl 'eql-specializer )
                                                     (not (eql (eql-specializer-object specl) ,req)) )
                                            (return eql) ) ))
                                 (return-from dispatch
                                   (call '(cdr specl.efm)) ) )) )) )) 

                 not-found
                   ;; Set new entry
                   (when (null (svref cache index))
                     (let ((emf
                            (if (eq (class-of gf) (find-class 'standard-generic-function))
                                (let ((methods (std-compute-applicable-methods gf (list ,@reqs))))
                                  (when methods
                                    (std-compute-effective-method
                                        gf
                                        (ref standard-generic-function method-combination (ref funcallable-instance storage gf))
                                        methods )) )
                              (let ((methods (compute-applicable-methods gf (list ,@reqs))))
                                (when methods
                                  (compute-effective-method
                                    gf
                                    (slot-value gf 'method-combination)
                                    methods )) )) ))
                       (unless emf
                         (return-from dispatch ,(call 'default-emf)) )

                       ,@(loop
                           for  req in reqs
                           for  index = 0 then (1+ index)
                           with offset = 0
                           when (svref speclvec index)
                             collect
                                `(setf (svref cache (+ ,offset index))
                                       (classd-of ,req) )
                             and do (incf offset) )

                       ,(if (not has-eql-p)
                            `(setf (svref cache (+ ,nspecls index)) emf)
                          `(setf (svref cache (+ ,nspecls index))
                                 (let ((method (first methods)))
                                   (if (not (has-eql-specializer-p method))
                                       emf
                                     (list
                                       (cons
                                         (slot-value method 'specializers)
                                         emf ))) )))

                       (return-from dispatch ,(call 'emf)) ))

                   ;; Go next entry
                   (setq index (logand (+ index ,line-size) mask))

                   ;; Enlarge cache
                   (when (eql start index)
                     (setq cache
                       (enlarge-method-cache cache ,nspecls ,line-size) )

                     (setq mask  (- (length cache) ,line-size))
                     (setq start (logand hash-code mask))
                     (setq index start) )

                   (go loop)

                 obsolete-instance
                   (return-from dispatch
                     ,(call '#'initial-discriminator 'gf) )) )) ) ) ) ) )


;;;; make-discriminator/checking
;;;
;;; Arguments and Values:
;;;   gf        - A generic-function.
;;;   param-info  - A param-info of gf.
;;;   method    - A method object.
;;;   default   - A function or symbol to be called when one of arguments
;;;               doesn't match a specializer. This is usually method-function
;;;               of default method or generic-function no-applicable-method.
;;;
;;; Description:
;;;  Returns discriminator for generic function, which has only
;;;  one specialized method.
;;;
;;;  The returned discriminator is closure that closes two objects,
;;;  generic-function and literal vector. The first element of literal
;;;  vector is method-function, the last element is default method function.
;;;  Other elements are specializes.
;;;
;;;   vector[0]   = method-function
;;;   vector[1]   = default method-function or no-applicable-method.
;;;   vector[2]   = specializer-1
;;;   ...
;;;   vector[n+1] = specializer-n
;;;
;;; Note: We will have runtime version of this funciton, which use
;;; precomputed or generic version instead of dyanmic constructor
;;; generation with compiler.
;;;
;;; BUGBUG: NYI: exclude unspecialized parameter.
;
(defun make-discriminator/checking (gf param-info has-eql-p method
                                    default-emf )
  (let* ((needs-next-methods-p (method-needs-next-methods-p method))
         (dname
           (compute-discriminator-name
             :check param-info has-eql-p needs-next-methods-p '() ) )
         (ctor
           ;; BUGBUG: NYI: lock *discriminator-constructors* table
           (gethash dname *discriminator-constructors*) ) )

    ;; Generate constructor
    ;;
    (unless ctor
      (let ((form (make-dfun-ctor/checking
                    param-info has-eql-p needs-next-methods-p dname ) ))
        (setq ctor (compile nil form))
        ;; BUGBUG: NYI: lock *discriminator-constructors* table
        (setf (gethash dname *discriminator-constructors*) ctor) ))

    ;; Make discriminator
    ;;
    (let ((vector (make-simple-vector
                        (+ 2 (ref param-info nreqs param-info)))))
      (setf (svref vector 0) (slot-value method 'function))
      (setf (svref vector 1) default-emf)
      (loop
        for specl in (slot-value method 'specializers)
        and index = 2 then (1+ index) do
          (setf (svref vector index) specl) )
      (let ((dfun (funcall ctor gf vector)))
        (setf (function-name dfun) (generic-function-name gf))
        dfun ) ) ) )


;;;; make-discriminator/dispatch
;;;
;;;     vector[0] = cache
;;;     vector[1] = default-emf
;;;     vector[2] = eql-methods (NYI)
;;;     vector[3] = line-size (for debugging)
;;;
;
(defun make-discriminator/dispatch (gf param-info eql-methods
                                       methods
                                       default-emf )
  (multiple-value-bind (speclvec nspecls)
      (summarize-specializers (ref param-info nreqs param-info) methods)
      (declare (type simple-vector speclvec))
      (declare (type (unsigned-byte 16) nspecls))

    (when (zerop nspecls)
      (return-from make-discriminator/dispatch
        (compute-effective-method
            gf
            (generic-function-method-combination gf)
            methods )))

    (let* ((dname
             (compute-discriminator-name
               :dispatch
               param-info
               eql-methods
               nil
               (loop for specl across speclvec collect specl) ) )
           (ctor
             ;; BUGBUG: NYI: lock dfun-ctor-table
             (gethash dname *discriminator-constructors*) ) )

      ;; Generate constructor.
      (when (null ctor)
        (let ((form (make-dfun-ctor/dispatch
                      param-info eql-methods dname speclvec nspecls) ))
          (setq ctor (compile nil form))
             ;; BUGBUG: NYI: lock dfun-ctor-table
          (setf (gethash dname *discriminator-constructors*) ctor) ))

      ;; Make discriminator
      (let* ((methods
               (if (null eql-methods)
                   methods
                 (set-exclusive-or methods eql-methods) ) )
             (line-size (power-2 (1+ nspecls)))
             (nmethods  (length methods))
             (tblsiz    (power-2 (* nmethods line-size)))
             (cache     (make-simple-vector tblsiz nil)) )
        (let ((dfun (funcall ctor gf cache default-emf)))
          (setf (function-name dfun) (generic-function-name gf))
          dfun ) ) ) ) )


;;;; make-temporary-lambda-list
;;;
;;; Arguments and Values:
;;;     reqs            -- A list of symbols.
;;;     opts            -- A list of lists contains symbol, nil and symbol.
;;;     var-rest        -- A symbol or null.
;;;     lambda-list     -- A lambda-list with temporary names.
;;;     ropts           -- A reverse list of opts.
;;; Called by:
;;;  make-dfun-ctor/checking
;;;  make-dfun-ctor/dispatch
;;;
;
(defun make-temporary-lambda-list (param-info)
    (declare (type param-info param-info))
    (declare (values list list symbol list list))
  (let* ((reqs
           (loop for index from 0 below (ref param-info nreqs param-info)
             collect
               (or (nth index '(r0 r1 r2 r3 r4 r5 r6 r7 r8 r9))
                   (gensym "r") )) )
         (opts
           (loop for index from 0 below (ref param-info nopts param-info)
             collect
               (or (nth index '((o1 nil s1)
                                (o2 nil s2)
                                (o3 nil s3)
                                (o4 nil s4)
                                (o5 nil s5)
                                (o6 nil s6)
                                (o7 nil s7)
                                (o8 nil s8)
                                (o9 nil s9) ))
                   (list (gensym "o") nil (gensym "s")) )) )
          (var-rest
            (and (ref param-info keys param-info) 'rest) )
          (lambda-list `(,@reqs
                         ,@(and opts `(&optional ,@opts))
                         ,@(and var-rest `(&rest ,var-rest)) ) ))
  (values reqs opts var-rest lambda-list (reverse opts)) ) )
